MacWorld 1998 March/Macworld (1998-03) (Disk 1).dmg/Shareware World/Utilities/Text Processing/Alpha/Tcl/Modes/tclMode.tcl

Text File | 1997-12-13 | 35.0 KB | 1,112 lines | [TEXT/ALFA]

## -*-Tcl-*- (install)
 # ###################################################################
 #    Vince's    Additions -    an extension package for Alpha
 #
 #    FILE: "tclMode.tcl"
 #                                 created: 6/8/95 {4:12:32 pm}
 #                                 last update: 13/12/97 {12:45:59 pm}
 #    Author:    Vince Darley
 #    E-mail:    <[e-mail]>
 #      mail:    Division of    Applied    Sciences, Harvard University
 #            Oxford Street, Cambridge MA    02138, USA
 #       www:    <http://www.fas.harvard.edu/~darley/>
 #
 # Copyright (c) 1997 Vince Darley
 #
 #    Three procs from original: Tcl::DblClick listArray, getVarValue
 #
 #    Adds support for Tk, Itcl keywords and completions, plus
 #    numerous fixes, improvements and integration with Vince's
 #    Additions.
 # ###################################################################
 ##

alpha::mode Tcl 1.4 tclMenu {*.tcl *.itcl *.itk} tclMenu {
    addMenu tclMenu "•269"
    set unixMode(wish) {Tcl}
    set unixMode(tclsh) {Tcl}
    ensureset tclshSig "WIsH"
    ensureset loadRemotely 0
    trace variable loadRemotely w loadRemoteSynchronise
} maintainer {
    "Vince Darley" [e-mail] <http://www.fas.harvard.edu/~darley/>
} uninstall this-file help {
    This mode is for editing Tcl code.  You can edit code for internal
    use with Alpha, or use Alpha as an external editor for code destined
    for use with Tcl and Tk interpreters --- Sun distributes the Wish
    application and a tcl-tk browser plugin.

    You can 'load' a procedure (or any Tcl code for that matter) to
    make changes on the fly.  If you select 'Load Remotely' in the
    tcl-tk submenu, then such actions will actually send the code
    to a separately running Wish application to be evaluated.
}


proc tclMenu {} {}

# ◊◊◊◊ menu and prefs ◊◊◊◊ #
# The menu.
proc menu::buildtclMenu {} {
    global tclMenu loadRemotely
    set ma [list \
      "/-<UswitchToTclsh" \
      [list menu -n "tcl-tk" -p tcltk::menuProc [list \
      "![lindex {{ } •} $loadRemotely]loadRemotely" \
      executeCommand]] \
      "(-" "/L<O<BloadProc" "/Z<O<BtraceThisProc" "/Z<O<UtraceTclProc…" \
      "/D<O<UdumpTraces" "(-" "rebuildTclIndices" "(-" \
      "<U/PfindProcDefinition…" "/P<IquickFindProc…" "getVarValue…" \
      "insertMenuCodes…" "insertBindingCodes…" "/4<BaddRemoveDollars" \
      "/3<BinsertDivider" "/8<I<BsurroundWithBullets"]
    return [list build $ma Tcl::MenuProc "" $tclMenu]
}
menu::buildProc tclMenu menu::buildtclMenu
menu::buildSome tclMenu

newPref v prefixString {# } Tcl
newPref f wordWrap {0} Tcl
newPref v funcExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
newPref v parseExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
newPref v wordBreak {(\$)?[\w:_]+} Tcl
newPref v wordBreakPreface {([^\w:_\$]|.\$)} Tcl
newPref f elecLBrace 1 Tcl
newPref f elecRBrace 1 Tcl
newPref f elecReturn 1 Tcl
newPref f autoMark 0 Tcl
newPref f electricTab 1 Tcl
newPref v stringColor green Tcl
newPref v commentColor red Tcl
newPref v keywordColor blue Tcl
newPref v alphaKeyWordColor    none Tcl stringColorProc
newPref f recogniseTk 1 Tcl Tcl::_updateKeywords
newPref f recogniseItcl 1 Tcl Tcl::_updateKeywords
newPref f recognisePseudoTcl 1 Tcl Tcl::_updateKeywords
newPref v indentSlashEndLines 1 Tcl "" indent::amounts varindex
newPref f structuralMarks 0 Tcl
set Tcl::startPara {^(.*\{)?[ \t]*(#|$)}
set Tcl::endPara {^(.*\})?[ \t]*(#|$)}

##
 # -------------------------------------------------------------------------
 #
 # "Tcl::_updateKeywords" --
 #
 #  This proc now includes support for optional separate colorization of
 #  alpha commands. To use, set 'alphaKeyWordColor' to something other than
 #  'none' in the Tcl Mode Preferences dialog. -trf
 # -------------------------------------------------------------------------
 ##
proc Tcl::_updateKeywords {args} {
    set tclKeyWords {
        after append array auto_execok auto_load auto_mkindex
        auto_reset beep binary break case catch cd clock close concat
        continue echo eof error eval exit expr fblocked fconfigure
        fcopy file fileevent flush for foreach format gets glob global
        history if incr info interp join lappend lindex linsert list
        llength load lrange lreplace ls lsearch lsort namespace open
        package pid pkg_mkIndex proc puts pwd read regexp regsub
        rename resource return scan seek set socket source split
        string subst switch tclMacPkgSearch tclPkgSetup tclPkgUnknown
        tell time trace unknown unset update uplevel upvar variable
        vwait while scancontext else elseif default
    }

    set alphaKeyWords {
        abortEm abbrev addAlphaChars addMenuItem addDef addArrDef
        AEBuild alertnote alphaHelp ascii askyesno backColor backSpace
        backwardChar backwardCharSelect backwardDeleteWord
        backwardWord balance beginningBufferSelect beginningLineSelect
        beginningOfBuffer beginningOfLine bind blink breakIntoLines
        bringToFront buttonAlert capitalizeRegion capitalizeWord
        centerRedraw clear closeAll colors colorTriple copy cp
        createTagFile createTMark currentPosition cut decToHex
        deleteChar deleteMenuItem deleteModeBindings deleteSelection
        deleteWord describeBinding deleteText dialog dirs display
        displayMode dosc downcaseRegion downcaseWord dumpColors
        dumpMacro edit enableMenuItem endBufferSelect endKeyboardMacro
        endLineSelect endOfBuffer endOfLine enterSelection
        eventHandler exchangePointAndMark execAbbrev execute
        executeKeyboardMacro fileInfo fileRemove find findAgain
        findAgainBackward findFile findInNextFile findTag float
        floatShowHide forwardChar forwardCharSelect forwardWord
        freeMem get_directory getAscii getChar getModifiers getColors
        getfile getFileInfo getGeometry getline getMainDevice getMark
        getNamedMarks getPathName getPos getScrap getSelect getText
        getTMarks getWinInfo goto gotoMark gotoTMark hexToDec icon
        icURL icGetPref icOpen insertAscii insertColorEscape
        insertFile insertMenu insertPathName insertText insertToTop
        isearch iterationCount jumpToRegister keyAscii keyCode
        killLine killWindow largestPrefix launch lineStart
        listBindings listpick lookAt markHilite markMenuItem
        matchBrace matchIt maxPos menu message mkdir mousePos
        moveInsertionHere moveFile moveWin mtime nameFromAppl new
        nextLine nextLineSelect nextLineStart nextSentence nextWindow
        now oneSpace openLine otherPane pageBack pageForward pageSetup
        paste pointToRegister popd posToRowCol prefixChar previousLine
        prevLineSelect prevSentence prevWindow print processes prompt
        pushd putfile putScrap quit rectMarkHilite redo
        regModeKeywords removeArrDef removeDef removeFile removeMark
        removeMenu removeTMark replace replaceAll replace&FindAgain
        replaceString replaceText restoreVars revert rmdir rowColToPos
        rsearch save saveAs saveVars scrollDownLine scrollLeftCol
        scrollRightCol scrollUpLine search searchString select selEnd
        sendOpenEvent sendToBack setFileInfo setFontsTabs setMark
        setNamedMark setWinInfo shell shiftLeftRegion shiftRightRegion
        sizeWin sortMarks spacesToTabs specToPathName splitWindow
        startEscape startKeyboardMacro statusPrompt substituteVars
        switchTo tab tabsToSpaces tclFileCompletion tclResult
        thinkReference ticks toggleScrollbar traceFunc unascii unbind
        undo unfloat upcaseRegion upcaseWord version watchCursor wc
        winNames wrap wrapText xtclcmd yank zapInvisibles zoom
    }

    set tkKeyWords {
        bindtags button canvas checkbutton console destroy entry event focus
        font frame grab grid image menubutton pack place radiobutton raise
        scale scrollbar text tk tkwait toplevel winfo wm label listbox
        menu
    }

    set itclKeyWords {
        @scope body class code component constructor define destructor hull
        import inherit itcl itk itk_component itk_initialize itk_interior
        itk_option iwidgets keep method private protected
        public
    }
    global TclmodeVars
    # add Tk keywords
    if {$TclmodeVars(recogniseTk)} {
        set tclKeyWords [concat $tclKeyWords $tkKeyWords]
    }
    # add the [incr tcl] keywords
    if {$TclmodeVars(recogniseItcl)} {
        set tclKeyWords [concat $tclKeyWords $itclKeyWords]
    }
    if {$TclmodeVars(recognisePseudoTcl)} {
        set tclKeyWords [concat $tclKeyWords "lunion lreverse lremove lunique car"]
    }
    # add user extras
    global Tclwords
    if {[info exists Tclwords]} {
        set tclKeyWords [concat $tclKeyWords $Tclwords]
    }
    global Tclcmds
    set Tclcmds { append array catch close concat continue elseif error
    for foreach format lindex llength lrange lreplace lsearch lsort regexp
    regsub rename return string switch while }
    if {$TclmodeVars(recogniseTk)} {
        append Tclcmds {
            tkButtonDown tkButtonEnter tkButtonInvoke tkButtonLeave
            tkButtonUp tkCancelRepeat tkCheckRadioInvoke tkDarken
            tkEntryAutoScan tkEntryBackspace tkEntryButton1
            tkEntryClosestGap tkEntryInsert tkEntryKeySelect
            tkEntryMouseSelect tkEntryNextWord tkEntryPaste
            tkEntryPreviousWord tkEntrySeeInsert tkEntrySetCursor
            tkEntryTranspose tkEventMotifBindings tkFDGetFileTypes
            tkFirstMenu tkFocusGroup_BindIn tkFocusGroup_BindOut
            tkFocusGroup_Create tkFocusGroup_Destroy tkFocusGroup_In
            tkFocusGroup_Out tkFocusOK tkListboxAutoScan
            tkListboxBeginExtend tkListboxBeginSelect tkListboxBeginToggle
            tkListboxCancel tkListboxDataExtend tkListboxExtendUpDown
            tkListboxMotion tkListboxSelectAll tkListboxUpDown tkMbButtonUp
            tkMbEnter tkMbLeave tkMbMotion tkMbPost tkMenuButtonDown
            tkMenuDownArrow tkMenuDup tkMenuEscape tkMenuFind
            tkMenuFindName tkMenuFirstEntry tkMenuInvoke tkMenuLeave
            tkMenuLeftArrow tkMenuMotion tkMenuNextEntry tkMenuNextMenu
            tkMenuRightArrow tkMenuUnpost tkMenuUpArrow tkMessageBox
            tkPostOverPoint tkRecolorTree tkRestoreOldGrab tkSaveGrabInfo
            tkScaleActivate tkScaleButton2Down tkScaleButtonDown
            tkScaleControlPress tkScaleDrag tkScaleEndDrag tkScaleIncrement
            tkScreenChanged tkScrollButton2Down tkScrollButtonDown
            tkScrollButtonUp tkScrollByPages tkScrollByUnits tkScrollDrag
            tkScrollEndDrag tkScrollSelect tkScrollStartDrag tkScrollToPos
            tkScrollTopBottom tkTabToWindow tkTearOffMenu tkTextAutoScan
            tkTextButton1 tkTextClosestGap tkTextInsert tkTextKeyExtend
            tkTextKeySelect tkTextNextPara tkTextNextPos tkTextNextWord
            tkTextPaste tkTextPrevPara tkTextPrevPos tkTextResetAnchor
            tkTextScrollPages tkTextSelectTo tkTextSetCursor
            tkTextTranspose tkTextUpDownLine tkTraverseToMenu
            tkTraverseWithinMenu tk_bisque tk_chooseColor tk_dialog
            tk_focusFollowsMouse tk_focusNext tk_focusPrev tk_getOpenFile
            tk_getSaveFile tk_messageBox tk_optionMenu tk_popup
            tk_setPalette tk_textCopy tk_textCut tk_textPaste
        }
    }

    if {$TclmodeVars(recogniseTk)} {
        regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
          -s $TclmodeVars(stringColor) \
          -k $TclmodeVars(keywordColor) Tcl $tclKeyWords
          # add this line if we can handle double 'magic chars'
          #-m {tk}
    } else {
        regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
          -s $TclmodeVars(stringColor) \
          -k $TclmodeVars(keywordColor) Tcl $tclKeyWords
    }
    if {$TclmodeVars(alphaKeyWordColor) != "none"} {
        regModeKeywords -a -k $TclmodeVars(alphaKeyWordColor) Tcl $alphaKeyWords
    }
}
# call it now
Tcl::_updateKeywords

proc Tcl::MenuProc {menu item} {
    switch -glob $item {
        "traceThisProc" {
            procs::traceProc [procs::findEnclosingName [getPos]]
        }
        "loadProc" {
            procs::loadEnclosing [getPos]
        }
        "findProcDefinition" {
            procs::findDefinition
        }
        "quickFindProc" {
            # use the status line
            procs::quickFindDefn
        }
        "switch*" {
            set v "[string tolower [string range $item 8 end]]Sig"
            global $v
            app::launchFore [set $v]
        }
        default {
            eval $item
        }
    }
}
namespace eval tcltk {}

proc tcltk::menuProc {menu item} {
    switch $item {
        "loadRemotely" {
            global loadRemotely
            set loadRemotely [expr 1 - $loadRemotely]
        }
        default {
            global tclshSig
            set cmd [getline "Please enter the script to send to tcl-tk"]
            set res [AEBuild -r -t 30000 '$tclshSig' misc dosc ---- "“$cmd”"]
            alertnote "Result was '$res'"
        }
    }
}

proc loadRemoteSynchronise {args} {
    global loadRemotely tclMenu
    catch {markMenuItem "tcl-tk" loadRemotely $loadRemotely}
    if $loadRemotely {
        if {[info commands notRemoteLoad] == ""} {
            rename load notRemoteLoad
            ;proc load {} {remoteLoad}
        }
        menu::replaceRebuild tclMenu "•320"
    } else {
        if {[info commands notRemoteLoad] != ""} {
            rename load {}
            rename notRemoteLoad load
        }
        menu::replaceRebuild tclMenu "•269"
    }
}

proc remoteLoad {} {
    global tclshSig
    app::ensureRunning $tclshSig
    set t [getSelect]
    catch {dosc -c '${tclshSig}' -s $t} r
    message "Remote reply: $r"
}
# ◊◊◊◊ Quick Find Proc… ◊◊◊◊ #
# "Quick Find Proc…" handler and sub-proc:
proc procs::quickFindDefn {} {
    global __keysSoFar __startIndex
    set __keysSoFar {}
    set __startIndex 0
    set __lastMatchsDisplayed {}

    message ""

    set patt ""
    set pos [getPos]

    set res [statusPrompt "proc name: " procs::Comp]
    message "Aborted: $patt"
    goto $pos
}

##
 # -------------------------------------------------------------------------
 #
 # "procs::Comp" --
 #
 #  The mods to this proc are along the lines of the proc that provides
 #  acronym-epansion in latex. Here you just type and get a list in the
 #  statusline of all the commands known to tcl that start with whatever
 #  you have typed so far. Whenever the set of commands share a common
 #  prefix that goes beyond what you have typed the "letters-entered"
 #  portion of the statusline advances to include all the common letters
 #  (this means you have to be careful you don't re-enter them manually, as
 #  that will likely abort entry as no command will match).
 #
 #  Once you have started entering characters, you are presented with the
 #  number of known cammands that start with those characters followed by
 #  s horizontal listing of as many of those commands that will fit on the
 #  line. These commands are separated by double spaces in order to make
 #  commands stand out as a whole to the eye (command with "::" in them
 #  are harder for the eyes to parse without this).
 #
 #  At this point you either keep entering characters to narrow the matching
 #  commands, type a tab to scroll through the horizontal list, or type a
 #  numeral that corresponds to the position one of the visible commands in
 #  the horizontal list (which will then be looked-up).
 #
 #  If you just keep entering characters til you narrow the list to one
 #  command, you might get down to a situation where the command you want
 #  out of the matches is contained in all the other matches. When this
 #  happens all you have to do is to type a <apace> and you will look-up
 #  that command.
 #
 #  To make things easier, whenever a character is entered that would abort
 #  the procedure, it is first check to see if the upperCase version of
 #  tht character would not keep us for aborting. For example, if you had
 #  'page…' as the entered portion, your list would be:
 #  (pageBackward  pageForward  pageSetup), so entering 'B' or 'b' would
 #  lookup pageBackward for you.
 #
 #  ToDo:
 #  • provide cushioning/alerting mechanism against aborting when the user
 #  does not notice that entered portion has been automatically extended.
 #  Perhaps, flash the statusline and color the automatically entered
 #  portion, and/or allow the rentering of the auto-entered portion.
 #  Of course insertColorEscape does not work in the statusline, but
 #  perhaps it would be possible figure out the escapes and enter them
 #  as literals via message.
 #  • perhaps alter this so you have the option of deleting characters
 #  instead of aborting when you get no matches.
 #  • perhaps provide a variant that inserts the found procName into your
 #  current cursor position instead of doing a look-up.
 #
 #  Note: made one change, moved the "number found:" portion of the prompt
 #  outside the horizontal list so it is easy to visually parse the list
 #  to determine what nember to hit to make a choice from the list.
 # -------------------------------------------------------------------------
 ##
proc procs::Comp {curr {key 0}} {
    global __keysSoFar __startIndex __lastStartIndex __lastMatchsDisplayed
    set mod [getModifiers]
    if {$mod && ($mod != 2)} {error ""}
    if {[string first $key "\034\035\036\037"] >= 0} {error ""}

    upvar patt pat
    if {$key == "\t"} {
        set __lastStartIndex $__startIndex
        set pats [lsort [info commands ${pat}*]]
        set pats [join [split $pats] "  "]
        set msg "proc '$pat…' ($pats)"
        if {[string length $msg] > 80} {
            set numFound [llength $pats]
            set nextIdx [expr $__startIndex + 1]
            set msg "proc '$pat…' $numFound found: ([lindex $pats $__startIndex] … »tab"
            while {($nextIdx < $numFound) && ([string length "$msg  [lindex $pats $nextIdx]"] <= 80)} {
                set matchsDisplayed [lrange $pats $__startIndex $nextIdx]
                incr nextIdx
                if {$nextIdx >= $numFound} {
                    set more ""
                } else {
                    set more "…"
                }
                if {$__startIndex == 0} {
                    set start ""
                } else {
                    set start "…"
                }
                set msg "proc '$pat…' $numFound found: ($start $matchsDisplayed $more) »tab"
            }
            if {$nextIdx >= [expr $numFound]} {
                set __lastStartIndex $__startIndex
                set __startIndex 0
            } else {
                set __lastStartIndex $__startIndex
                set __startIndex [expr $nextIdx]
            }
        }
        message $msg
        set __lastMatchsDisplayed $matchsDisplayed
        return {}
    }
    if {$key == " "} {
        set pats [join [split [lsort [info commands $__keysSoFar]] ] "  "]
    } elseif {([string first $key "123456789"] >= 0) && (![llength [info commands $__keysSoFar$key*]])} {
        if {$key <= [llength $__lastMatchsDisplayed]} {
            set pats [lindex "null $__lastMatchsDisplayed" $key]
        } else {
            error ""
        }
    } else {
        set pats [join [split [lsort [info commands $__keysSoFar$key*]] ] "  "]
    }

    set numFound [llength $pats]
    if {!$numFound} {
        # first we'll see if the user was just too lazy to shift the key
        set pats [join [split [lsort [lsort [info commands $__keysSoFar[string toupper $key]*]]] ] "  "]
        set numFound [llength $pats]
    }
    append __keysSoFar $key
    set pat $__keysSoFar
    switch $numFound {
        0 {
            error "No procs."
            beep
        }
        1 {
            set pat $pats
            message "proc or command -- '$pat'"
            # to handle Tcl and Alpha built in commands -trf
            Tcl::DblClickHelper $pat
            error ""
        }
        default {
            set pat [largestPrefix $pats]
            set __keysSoFar $pat
            set matchsDisplayed $pats
            set msg "proc '$pat…' ($matchsDisplayed)"
            if {[string length $msg] > 80} {
                set matchsDisplayed [lindex $pats 0]
                set nextIdx 1
                set msg "proc '$pat…' $numFound found: ($matchsDisplayed …) »tab"
                while {($nextIdx < $numFound) && ([string length "$msg [lindex $pats $nextIdx]"] <= 80)} {
                    append matchsDisplayed "  " [lindex $pats $nextIdx]
                    incr nextIdx
                    set msg "proc '$pat…' $numFound found: ($matchsDisplayed …) »tab"
                }
                if {$nextIdx > [expr $numFound]} {
                    set __lastStartIndex $__startIndex
                    set __startIndex 0
                } else {
                    set __lastStartIndex $__startIndex
                    set __startIndex [expr $nextIdx -1]
                }

            }
            set __lastMatchsDisplayed $matchsDisplayed
            message $msg
        }
    }
    return {}
}
# ◊◊◊◊ electric behaviour ◊◊◊◊ #
proc Tcl::electricLeft {} {
    if [literalChar] { insertText "\{"; return }
    set pat {\}[ \t\r]*(else(if)?)[ \t\r]*$}
    set p [getPos]
    if { [set res [findPatJustBefore "\}" "$pat" $p word]] == "" } {
        insertText "\{"
        return
    }
    # we have an if/else(if)/else
    switch $word {
        "else" {
            replaceText [lindex $res 0] $p "\} $word \{\r"
            bind::IndentLine
        }
        "elseif" {
            replaceText [lindex $res 0] $p "\} $word \{"
        }
    }
}

proc Tcl::electricRight {} {
    if [literalChar] { insertText "\}"; return }
    set p [getPos]
    if { [regexp {[^ \t]} [getText [lineStart $p] $p]] } {
        insertText "\}"
        blink [matchIt "\}" [expr $p - 1]]
        return
    }
    set start [lineStart $p]
    insertText "\}"
    createTMark tcl_er [getPos]
    backwardChar
    bind::IndentLine
    gotoTMark tcl_er ; removeTMark tcl_er
    bind::CarriageReturn
    blink [matchIt "\}" [expr $start -1]]
}

##
 # -------------------------------------------------------------------------
 #
 # "Tcl::correctIndentation" --
 #
 #  Returns the correct indentation for the line containing $pos, if that
 #  line were to contain ordinary characters only.  It is the
 #  responsibility of the calling procedure to ensure that if we are to
 #  insert/have a line already, that that information is taken into
 #  account, by passing in the argument 'next'
 # -------------------------------------------------------------------------
 ##
proc Tcl::correctIndentation {pos {next ""}} {
    global indent_amounts indentSlashEndLines
    # preliminaries
    if {[set beg [lineStart $pos]] == 0} { return 0 }
    # if the current line is a comment, we have to check some
    # special cases
    if {[set next [string index $next 0]] == "\#"} {
        set p [prevLineStart $beg]
        set prev [text::firstNonWsLinePos $p]
        if {[lookAt $prev] != "\#" || ($beg == 0)} {
            # not a comment, so indent with code
        } else {
            set lwhite [posX $prev]
            # it's a comment
            if {[getText $prev [expr $prev + 2]] == "\#\#" && \
                [lookAt [expr $prev +2]] != "\#" } {
                # it's a comment paragraph
                incr lwhite
            }
        }
    }
    if ![info exists lwhite] {
        if ![catch {search -s -f 0 -r 1 -i 0 -m 0 {^[ \t]*[^\# \t\r\n]} [expr $beg-1]} lst] {
            # Find the last non-comment line and get its leading whitespace
            set lwhite [posX [expr [lindex $lst 1] - 1]]
            set pe1 [lookAt [expr $beg -2]]
            set lst [lindex $lst 0]
            set lastC [lookAt [lindex [search -s -f 0 -r 1 -i 0 -m 0 {[^ \t\r\n]} [expr [nextLineStart $lst] - 1]] 0]]
            if {$next == "\}"} {
                incr lwhite $indent_amounts(-2)
                set pe2 [lookAt [expr [prevLineStart $beg] -2]]
                if {$pe1 == "\\"} {
                    incr lwhite $indent_amounts(1)
                } else {
                    if {$pe2 == "\\"} {
                        incr lwhite $indent_amounts(-1)
                    }
                }
                if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}
            } else {
                if {$pe1 == "\\"} {
                    if {[lookAt [expr [prevLineStart $beg] -2]] != "\\"} {
                        incr lwhite $indent_amounts($indentSlashEndLines)
                    }
                } else {
                    if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}
                    if {[lookAt [expr $lst -2]] == "\\"} {
                        incr lwhite $indent_amounts(-$indentSlashEndLines)
                    }
                }
            }
        } else {
            # basically failed in all the above, so keep current indentation
            set lwhite [posX [text::firstNonWsLinePos $beg]]
        }
    }
    return $lwhite
}

##
 # -------------------------------------------------------------------------
 #
 # "Tcl::indentLine" --
 #
 #  Indentation for Tcl mode.  Better and faster than the generic procedure
 # -------------------------------------------------------------------------
 ##
proc Tcl::indentLine {} {
    set beg [lineStart [getPos]]
    set text [getText $beg [nextLineStart $beg]]
    regexp {^[ \t]*} $text white
    set next [expr $beg +[string length $white]]
    set lwhite [Tcl::correctIndentation [getPos] [lookAt $next]]

    set lwhite [text::indentOf $lwhite]
    if {$white != $lwhite} {
        replaceText $beg $next $lwhite
    }
    goto [expr $beg + [string length $lwhite]]
}
# ◊◊◊◊ Tcl Menu support ◊◊◊◊ #
proc procs::loadEnclosing {pos} {
    if [catch {set p [procs::findEnclosing $pos proc 1] } ] {
        loadLine $pos
    } else {
        eval select $p
        uplevel \#0 load
    }
    goto $pos
}

proc procs::traceProc {func} {
    global tclMenu
    # if we're tracing already then clear it
    if {[llength [traceFunc status]]>2} { traceTclProc }
    traceFunc on $func ""
    catch {markMenuItem $tclMenu {traceTclProc…} on}
    catch {enableMenuItem $tclMenu dumpTraces on}
    message "Tracing '$func'…"
}

proc procs::findDefinition {} {
    if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
        set func [listpick -L $sel -p {Proc?} [lsort -ignore [info procs]]]
    } else {
        set func [listpick -p {Proc?} [lsort -ignore [info procs]]]
    }

    editMark [procs::find $func] $func
}

proc insertMenuCodes {} {
    insertText [prompt::getAKey]
}

proc insertBindingCodes {} {
    beep
    keyCode
}

proc addRemoveDollars {} {
    set p [getPos]
    backwardWord
    if {[lookAt [getPos]] == "\$"} {
        deleteChar
        goto [expr $p -1]
    } else {
        insertText "\$"
        goto [expr $p +1]
    }
}

##
 # -------------------------------------------------------------------------
 #
 # "insertDivider" --
 #
 #  Modified from Vince's original to allow you to just select part of
 #  an already written comment and turn it into a Divider. -trf
 # -------------------------------------------------------------------------
 ##
proc insertDivider {} {
    if {[isSelection]} {
        set enfoldThis [getSelect]
        beginningOfLine
        killLine
        insertText "# ◊◊◊◊ $enfoldThis ◊◊◊◊ #"
        return
    }
    elec::Insertion "# ◊◊◊◊ •• ◊◊◊◊ #"
}

# vince's versions seems to have been left out, so here's mine -trf
# If there is a selection, it get surrounded, if there is no selection,
# but the cursor is touching the end of a word, it gets surrounded.
# Otherwise, we get a template (could not come up with a "stop beyond")
proc surroundWithBullets {} {
    if {[getPos]==[selEnd]}    {
        set p [getPos]
        backwardWord
        set sw [getPos]
        forwardWord
        set ew [getPos]
        goto $p
        if {$p == $ew} {
            select $sw $ew
        }
    }
    if {[isSelection]} {
        set enfoldThis [getSelect]
        deleteSelection
        insertText "•$enfoldThis•"
        return
    }
    insertText "••"
    backwardChar
    elec::Insertion "•replace-this•"
}
# ◊◊◊◊ Info providers ◊◊◊◊ #
#===============================================================================

##
 # -------------------------------------------------------------------------
 #
 # "TclOptionTitlebar" --
 #
 #  Add corresponding extension/non-extension files.
 # -------------------------------------------------------------------------
 ##
proc Tcl::OptionTitlebar {} {
    if [package::active smarterSource] {
        set n [win::CurrentTail]
        if {[set a [string first + $n]] != -1} {
            return "[string range $n 0 [expr $a -1]][file extension $n]"
        } else {
            global tclExtensionsFolder
            pushd $tclExtensionsFolder
            set f [glob -nocomplain "[file root $n]+*[file extension $n]"]
            popd
            return $f
        }
    } else {
        return ""
    }
}

proc Tcl::DblClick {from to shift option control} {

    # if cmd and cntrl were pressed, we look to select part of
    # a combination word (less any leading dollar sign) -trf
    if {$control != 0} {
        set clickedPos [getPos]
        if {[lookAt $from] == "\$"} {
            incr from
        }
        set sel_start $clickedPos
        set    selStartNotDetermined 1
        while {$selStartNotDetermined && ($sel_start > $from)} {
            set char [lookAt $sel_start]
            if {[regexp {_} $char]} {
                incr sel_start
                set selStartNotDetermined 0
            } elseif {[regexp {[A-Z]} $char]} {
                set selStartNotDetermined 0
            } else {
                incr sel_start -1
            }
        }
        set sel_end   $clickedPos
        set    selEndNotDetermined 1
        while {$selEndNotDetermined && ($sel_end <= $to)} {
            set char [lookAt $sel_end]
            if {[regexp "\[A-Z_ \t\r\]" $char]} {
                set selEndNotDetermined 0
            } else {
                incr sel_end
            }
        }
        select $sel_start $sel_end
        return
    }

    # otherwise, we try to impart some extra info
    select $from $to

    if [catch {Tcl::DblClickHelper [getSelect]}] {
        message "No docs $shift $control $option"
    }
}


# Now finds commands in Alpha Commands,
# which has a <cr> immediately after them, e.g. beep, ticks.
proc Tcl::DblClickHelper {text} {
    global HOME auto_index auto_path
    # Is it a loadable proc?
    if {[string length [set f [procs::find $text]]]} {
        editMark $f $text
        return
    }

    if {[info exists "auto_index($text)"]} {
        editMark "$auto_index($text)" $text
        return
    }
    # Is it a built-in Alpha command?
    set lines [grep "^• $text\( |$)" "$HOME:Help:Alpha Commands"]
    if {[string length $lines]} {
        editMark "$HOME:Help:Alpha Commands" $text
        setWinInfo read-only 1
        return
    }
    # Is it a core Tcl command?
    set lines [grep "^     $text -" "$HOME:Help:Tcl Commands"]
    if {[string length $lines]} {
        editMark "$HOME:Help:Tcl Commands" $text
        setWinInfo read-only 1
        return
    }
    # Is it a global variable?
     if {[llength [info globals [string trimleft $text {$}]]]==1} {
        showVarValue [string trimleft $text {$}]
        return
    }
    # (becoming desperate) is it a mark in the current file?
    if {[lsearch [getNamedMarks -n] ${text}] != -1} {
        gotoMark $text
        return
    }
    error ""
}

#############################################################################
#  Report the current value of a global variable, chosen interactively
#  from a list of all active variables.
#
#  If the variable is an array, or its value is too big to fit in an
#  alertnote, then its contents are listed in a new window, otherwise
#  the variable's value is displayed in an alertnote.
#
proc getVarValue {} {
    set def [getText [getPos] [selEnd]]
    set var [listpick -p {Which var?} -L $def [lsort -ignore [info globals]]]
    if {![string length $var]} return
    showVarValue $var
}

#############################################################################
#  Report the current value of a global variable, chosen interactively
#  from a list of all active variables.
#
#  If the variable is an array, or its value is too big to fit in an
#  alertnote, then its contents are listed in a new window, otherwise
#  the variable's value is displayed in an alertnote.
#
proc showVarValue {var} {
    global $var
    if {![catch {set $var} value]} {
        viewValue $var $value
        return
    } else {
        regsub -all : $var . var1
        new -n "* $var1 *"
        listArray $var
    }
    goto 0
    # if 'shrinkWindow' is loaded, call it to trim the output window.
    catch {shrinkWindow 2}
    winReadOnly
}

#############################################################################
#  List the name and value of each element of the array $arrName.
#  (Convenient to use as a shell command.)
#
proc listArray {arrName} {
    global $arrName
    set lines {}
    if {![catch {info vars $arrName}]} {
        foreach nm [array names $arrName] {
            # modified to handle odd named arrays -trf
            set val [eval set \{$arrName\($nm\)\}]
            append lines "\r\"$nm\"\t\{$val\}"
        }
        insertText $lines
    } else {
        alertnote "\"$arrName\" doesn't exist in this context"
    }
}

# ◊◊◊◊ Marking ◊◊◊◊ #
# note: I put these procs in this order to reflect where you go to activate
#  them, i.e. parseFuncsTcl via 'braces' pop-up, which is on top of the
# 'M' pop-up (invokes Tcl::MarkFile).

##
 # -------------------------------------------------------------------------
 #
 # "parseFuncsTcl" --
 #
 #    This proc is called    by the "braces"    pop-up.    It returns a dynamically
 #    created, alphabetical, list of    "pseudo-marks".
 #
 #    Author:    Tom    Fetherston
 # -------------------------------------------------------------------------
 ## called by the "{}" button
proc Tcl::parseFuncs {} {
    global TclmodeVars
    set end [maxPos]
    set pos 0
    set l {}
    set markExpr {^[ \t]*((itcl(::|_))?class|body|proc|method|body)[ \t]}
    set appearanceList {}
    while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
        set start [lindex $res 0]
        set end [nextLineStart $start]
        set t [getText $start $end]
        switch [lindex $t 0] {
            "proc" {
                set argLabel {}
                append argLabel [set word [lindex $t 1] ]
                #get the list of arguments
                set argsList [lindex $t 2]
                if {[llength $argsList] > 0} {
                    append argLabel " \{"
                    foreach arg $argsList {
                        if {[llength $arg] == 2 } {
                            append argLabel "¿"
                        } elseif {[set arg] != "args"} {
                            append argLabel "•"
                        } else {
                            append argLabel "…"
                        }
                    }
                    append argLabel "\}"
                }
            }
        }
        if {[info exists cnts($word)]} {
            # This section handles duplicate. i.e., overloaded names
            set cnts($word) [expr $cnts($word) + 1]
            set tailOfTag($word) " ($cnts($word) of $cnts($word))"
            # we want the tag to point to its last occurence
            # because in Tcl, that proc will be 'in-force' when the
            # file is loaded.
            set indx($word) [lineStart [expr $start - 1]]
        } else {
            #SO do: remember the following
            set cnts($word) 1
            # if this is the only occurence of this proc, remember where it starts
            set indx($word) [lineStart [expr $start - 1]]
        }
        #associate name and tag
        set tag($word) $argLabel

        #advance pos to where we want to start the next search from
        set pos $end
    }

    set rtnRes {}

    if {[info exists indx]} {
        foreach hn [lsort -ignore [array names indx]] {
            set next [nextLineStart $indx($hn)]
            set completeTag [set tag($hn)]
            if {[info exists tailOfTag($hn)]} {
                append completeTag [ set tailOfTag($hn) ]
            }

            lappend rtnRes $completeTag $next
        }
    }
    return $rtnRes
}

# called by the "M" button
proc Tcl::MarkFile {} {
    global structuralMarks
    set end [maxPos]
    set pos 0
    set l {}
    if $structuralMarks {
        set markExpr {^;?[     ]*((itcl(::|_))?class|proc|method|body|# ◊◊◊◊)[     ]}
    } else {
        set markExpr {^;?[     ]*((itcl(::|_))?class|proc|method|body)[     ]}
    }
    set class ""
    set hasMarkers 0
    while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
        set start [lindex $res 0]
        set end [nextLineStart $start]
        set t [getText $start $end]
        regsub -all {[\{\}]} [string trimleft $t ";"] {\\&} t
        switch -glob [lindex $t 0] {
            "proc" { set text [lindex $t 1] }
            "method" { set text ${class}::[lindex $t 1] }
            "body" {
                regexp {[a-zA-Z_][a-zA-Z_/0-9]*::[a-zA-Z_][a-zA-Z_/0-9]* } \
                  "[lindex $t 1] " text
            }
            "*class" {
                set class [lindex $t 1]
                set text "${class} 000"
            }
            "#" {
                regexp "# ◊◊◊◊ (.*) ◊◊◊◊ #" $t all text
                if {[regexp "^(    )|(    )# ◊◊◊◊ " $t]} {
                    set text " •$text"
                } else {
                    set text "•$text"
                }
                set hasMarkers 1
            }
        }
        set pos $end
        if {$structuralMarks} {
            lappend asEncountered $text
            set arr inds
        } else {
            if {[string index $t 0] == ";"} {
                set arr iinds
            } else {
                set arr inds
            }
        }
        set ${arr}($text) [lineStart [expr $start - 1]]
    }

    set already ""
    set class "#"
    foreach arr {inds iinds} {
        if {[info exists $arr]} {
            if {$arr == "iinds"} {
                setNamedMark "-" 0 0 0
            }
            if $structuralMarks {
                set order $asEncountered
            } else {
                set order [lsort -ignore [array names $arr]]
            }
            foreach f $order {
                if {[set el [set ${arr}($f)]] != 0} {
                    set next [nextLineStart $el]
                } else {
                    set next 0
                }

                if { [string first "000" $f] != -1 } {
                    set ff "Class '[set class [lindex $f 0]]'"
                } elseif { [string first "${class}::" $f] != -1 } {
                    set ff [string range $f [string length $class] end]
                } else {
                    set ff $f
                }
                while { [lsearch -exact $already $ff] != -1 } {
                    set ff "$ff "
                }
                lappend already $ff
                if {$hasMarkers && ![string match "•*" $ff] } {
                    set ff " $ff"
                }
                setNamedMark $ff $el $next $next
            }
        }
    }
}

# ◊◊◊◊ Misc. ◊◊◊◊ #

##
 # -------------------------------------------------------------------------
 #
 # "bind::tclContinueComment" --
 #
 #  exploits a "feature" in the code that makes a new line a comment whenever
 #  you are 'inside' a comment. This proc puts a pound sign at the end of the
 #  current line, backsteps, and creates a new line. With the pound sign
 #  present you are considered to be in a comment, so the bind::CarriageReturn
 #  in the proc, and any subsequent bind::CarriageReturn called by a press of
 #  the return key will provide another comment line automatically until the
 #  pound sign at the end of the line is removed (killLine is handy for this).
 # -------------------------------------------------------------------------
 ##
proc bind::tclContinueComment {} {
    insertText {#}
    backwardChar
    bind::CarriageReturn
}
bind '\r' <c> bind::tclContinueComment Tcl

proc loadLine { pos } {
    goto $pos
    beginningLineSelect
    endLineSelect
    uplevel \#0 load
}

#◊◊◊◊>

loadRemoteSynchronise